{-# LANGUAGE ViewPatterns #-}
-----------------------------------------------------------------------------
--
-- Module      :  LLVM.Code.Instructions.Aggregate
-- Copyright   :  Mikhail Belyaev
-- License     :  GPL (Just (Version {versionBranch = [3], versionTags = []}))
--
-- Maintainer  :
-- Stability   :
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------

module LLVM.Code.Instructions.Aggregate where


import LLVM.Code.Shared (ValIndex(..), TypeIndex(..))
import LLVM.Parser.Record.Record
       (getCode, recordAsHeadlessList, recordAsList, RecordType(..))

import LLVM.Util
import LLVM.Code.Values (TypedValue(..), getValueType)
import LLVM.Code.Instructions.Class (BuildableInstruction(..))
import LLVM.Code.Types (getTypeByIndex, Type)
import LLVM.Code.Instructions.Util
       (rrstruct, Unwrappable(..), Matched(..), Matcher(..),
        matchRRwithCode)
import LLVM.Code.Instructions.Values
       (GetElementPtrInstruction(..), InsertValueInstruction(..),
        ExtractValueInstruction(..), ShuffleVecInstruction(..),
        InsertElementInstruction(..), ExtractElementInstruction(..))

-- Vector instructions



instance BuildableInstruction ExtractElementInstruction where
    buildInstruction rr tt vt =
        case (matchRRwithCode tt vt [MValueTypePair,MValue] 6 rr) of
             (MdValueTypePair (vi,ti) : MdValue ix : _) ->
                    Just ExtractElementInstruction {
                             extractElType = ti,
                             extractElVal = vi,
                             extractElIx = ix
                    }
             _ -> Nothing




instance BuildableInstruction InsertElementInstruction where
    buildInstruction rr tt vt =
        case (matchRRwithCode tt vt [MValueTypePair,MValue,MValue] 7 rr) of
             [MdValueTypePair (v,ty), MdValue e, MdValue ix] ->
                    Just InsertElementInstruction{
                        insertElType = ty,
                        insertElVal = v,
                        insertElElem = e,
                        insertElIx = ix
                    }
             _ -> Nothing



instance BuildableInstruction ShuffleVecInstruction where
    buildInstruction rr tt vt =
        case (matchRRwithCode tt vt [MValueTypePair,MValue,MValue] 8 rr) of
             [MdValueTypePair (v1,ty), MdValue v2, MdValue m] ->
                    Just ShuffleVecInstruction{
                            shuffleType = ty,
                            shuffleVec1 = v1,
                            shuffleVec2 = v2,
                            shuffleMask = m
                    }
             _ -> Nothing

-- other aggregates



instance BuildableInstruction ExtractValueInstruction where
    buildInstruction rr@(getCode -> Just 25) tt vt =
        case (matchRRwithCode tt vt [MValueTypePair, MInteger] 25 rr) of
             [MdValueTypePair (v,ty), MdInteger ix] ->
                    Just ExtractValueInstruction{
                        extractValType = ty,
                        extractValVal = v,
                        extractValIx = [ix]
                    }
             _ -> Nothing
    buildInstruction rr@(getCode -> Just 26) tt vt =
        case (matchRRwithCode tt vt [MValueTypePair, MMany MInteger] 26 rr) of
             [MdValueTypePair (v,ty), (unwrap -> Just ixs)] ->
                    Just ExtractValueInstruction{
                        extractValType = ty,
                        extractValVal = v,
                        extractValIx = ixs
                    }
             _ -> Nothing
    buildInstruction _ _ _ = Nothing





instance BuildableInstruction InsertValueInstruction where
    buildInstruction rr tt vt =
        case (matchRRwithCode tt vt [MValueTypePair, MValueTypePair, MMany MInteger] 27 rr) of
             [MdValueTypePair (v,ty), MdValueTypePair (e,et), (unwrap -> Just ixs)] ->
                    Just InsertValueInstruction{
                        insertValType = ty,
                        insertValVal = v,
                        insertValElemType = et,
                        insertValElem = e,
                        insertValIx = ixs
                    }
             _ -> Nothing


instance BuildableInstruction GetElementPtrInstruction where
    buildInstruction rr@(getCode -> cd) tt vt | cd == Just 4 || cd == Just 30 =
        case (rrstruct tt vt [MValueTypePair, MMany MValueTypePair] rr) of
             [MdValueTypePair (v,ty), (unwrap -> Just ixs)] ->
                    Just $ GetElementPtrInstruction{
                        gepValType = ty,
                        gepVal = v,
                        gepIxs = map (\(x,y) -> (y,x)) ixs,
                        gepIsInBounds = (cd == Just 30) -- true for 30, false for 4
                    }
             _ -> Nothing
    buildInstruction _ _ _ = Nothing

